perm filename T2.F4[M11,LCS]2 blob
sn#396925 filedate 1978-11-22 generic text, type T, neo UTF8
00100 C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
00200 C INTO THE IX ARRAY. IX ARRAY ADVANCES 2 WORDS AT A TIME.
00300 C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
00400 C KCNT IS WORD COUNT OF INPUT STRING.
00500 SUBROUTINE MPACK(KCNT, I,IX,IPTR)
00600 COMMON/IGEN/IGEN
00700 COMMON /TR/Q(80),QX(100),IIX(100),LX(12),INST(27,5),MX5(40)
00800 DIMENSION I(1)
00900 DATA IPP/'P'/,IFF/'F'/,IBB/'B'/,IAA/'A'/,IOO/'O'/,IRR/'R'/,
01000 1 IEE/'E'/,ISS/'S'/,IMM/'M'/,III/'I'/,ILL/'L'/,ITT/'T'/,
01100 1 IDD/'D'/,I2/'2'/,I3/'3'/,I4/'4'/,IUU/'U'/,ICC/'C'/,IHH/'H'/
01200 1,IVV/'V'/,IYY/'Y'/,IWW/'W'/,I0/'0'/,I9/'9'/,INN/'N'/,IQQ/'Q'/
01300 1,IPP/'P'/,IGG/'G'/
01400 IX=I(1)
01500 DO 100 K=1,12
01600 IF(IX.NE.LX(K))GO TO 100
01700 C LOOK FOR PUNCTUATION, ARITHMETIC OPERATORS, ETC.
01800 RETURN
01900 100 CONTINUE
02000 101 N=I(2)
02100 L=I(3)
02200 IF(IGEN.NE.2)GO TO 1000
02300 C IGEN=2=READING INSTRUMENT DEFINITION
02400 CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
02500 C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,SET,RAH,END,INS
02600 IF(IX.EQ.IPP)GO TO 14
02700 IF(IX.EQ.IFF)GO TO 15
02800 IF(IX.EQ.IBB)GO TO 16
02900 IF(IX.EQ.IAA)GO TO 1
03000 IF(IX.EQ.IOO)GO TO 2
03100 IF(IX.EQ.IRR)GO TO 3
03200 IF(IX.EQ.IEE)GO TO 4
03300 IF(IX.EQ.ISS)GO TO 5
03400 IF(IX.EQ.IMM)GO TO 17
03500 IF(IX.EQ.III)GO TO 33
03600 C IF NOT A KNOWN WORD THEN ERROR
03700 999 CALL ERR(5)
03800 C NEXT FOR 'MLT'
03900 17 IF(N.NE.ILL)GO TO 999
04000 IF(L.NE.ITT)GO TO 999
04100 IX=9
04200 RETURN
04300 1 IF(N.NE.IDD)GO TO 999
04400 IF(L.EQ.I2)GO TO 6
04500 C 'AD2, AD3, AD4'
04600 IF(L.EQ.I3)GO TO 7
04700 IF(L.NE.I4)GO TO 999
04800 IX=8
04900 RETURN
05000 6 IX=3
05100 RETURN
05200 7 IX=7
05300 RETURN
05400 2 IF(N.EQ.ISS)GO TO 10
05500 IF(N.NE.IUU)GO TO 200
05600 IF(L.NE.ITT)GO TO 999
05700 C 'OUT'
05800 IX=1
05900 RETURN
06000 200 IF(N.NE.IPP)GO TO 999
06100 IF(L.NE.ITT)GO TO 999
06200 C 'OPT' OPTIONAL USER-ADDED UNIT GENERATOR CODE=14 IN MSCAN.
06300 IX=14
06400 RETURN
06500 10 IF(L.NE.ICC)GO TO 999
06600 C 'OSC'
06700 IX=2
06800 RETURN
06900 3 IF(N.NE.IAA)GO TO 999
07000 IF(L.EQ.INN)GO TO 11
07100 IF(L.NE.IHH)GO TO 999
07200 C 'RAN', 'RAH'
07300 IX=11
07400 RETURN
07500 11 IX=4
07600 RETURN
07700 4 IF(N.NE.INN)GO TO 999
07800 IF(L.EQ.IVV)GO TO 12
07900 C ENV, END
08000 IF(L.NE.IDD)GO TO 999
08100 IX=12
08200 RETURN
08300 12 IX=5
08400 RETURN
08500 5 IF(N.EQ.ITT)GO TO 13
08600 IF(N.NE.IEE)GO TO 999
08700 C SET, STR
08800 IF(L.NE.ITT)GO TO 999
08900 IX=10
09000 RETURN
09100 13 IF(L.NE.IRR)GO TO 999
09200 IX=6
09300 RETURN
09400 14 J=200
09500 C PN
09600 18 IF(N.LT.I0.OR.N.GT.I9)GO TO 999
09700 K2=0
09800 K1=NASCI(N)
09900 CXX K1=N-8240
10000 C CONVERTS ASCII CHAR. TO INTEGER ('0'=8240)
10100 IF(KCNT.EQ.2)GO TO 19
10200 C ARE THERE 2 DIGITS AFTER P, F OR B?
10300 IF(L.LT.I0.OR.L.GT.I9)GO TO 999
10400 K1=K1*10
10500 CXX K2=L-8240
10600 K2=NASCI(L)
10700 19 IX=J+K1+K2
10800 RETURN
10900 15 J=300
11000 C FN
11100 GO TO 18
11200 16 J=100
11300 C BN
11400 GO TO 18
11500
11600 C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
11700 1000 IF(KCNT.LE.3)GO TO 2000
11800 C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
11900 LN=I(4)
12000 IF(IX.EQ.IPP)GO TO 20
12100 C THIS LIST BEGINS WITH CODE NUM. 400:
12200 C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,GEN,DUR,FREQ,INSTRU,UNIT GEN.
12300 IF(IX.EQ.IFF)GO TO 21
12400 IF(IX.EQ.ISS)GO TO 22
12500 IF(IX.EQ.INN)GO TO 23
12600 IF(IX.EQ.III)GO TO 27
12700 IF(IX.NE.IUU)GO TO 28
12800 C JUMP IF NOT ONE OF THE SPECIAL WORDS. IT MAY BE AN INSTR.
12900 C****** INSTRS CANNOT HAVE SAME NAME(1ST 4 LTRS) AS ANY OF THESE WORDS*******
13000 IF(N.NE.INN)GO TO 28
13100 IF(L.NE.III)GO TO 28
13200 IF(LN.NE.ITT)GO TO 28
13300 C UNIT GEN (FOR SPECIAL DEFINITIONS)
13400 IX=413
13500 RETURN
13600 20 IF(N.NE.ILL)GO TO 30
13700 IF(L.NE.IAA)GO TO 28
13800 IF(LN.NE.IYY)GO TO 28
13900 C PLAY
14000 IX=400
14100 RETURN
14200 30 IF(N.NE.IRR)GO TO 31
14300 IF(L.NE.III)GO TO 28
14400 IF(LN.NE.INN)GO TO 28
14500 C PRINT
14600 IX=404
14700 RETURN
14800 31 IF(N.NE.IOO)GO TO 28
14900 IF(L.NE.IWW)GO TO 28
15000 IF(LN.NE.IEE)GO TO 28
15100 C POWER(X,Y)
15200 IX=406
15300 RETURN
15400 21 IF(N.NE.III)GO TO 32
15500 IF(L.NE.INN)GO TO 28
15600 IF(LN.NE.III)GO TO 28
15700 C UNIT GEN (FOR SPECIAL DEFINITIONS)
15800 IX=401
15900 RETURN
16000 22 IF(N.NE.IRR)GO TO 28
16100 IF(L.EQ.ITT.AND.KCNT.EQ.3)GO TO 222
16200 IF(L.NE.IAA)GO TO 29
16300 IF(LN.NE.ITT)GO TO 28
16400 C SRATE, SRT
16500 222 IX=402
16600 RETURN
16700 29 IF(L.NE.ITT)GO TO 28
16800 IX=407
16900 RETURN
17000 23 IF(N.NE.ICC)GO TO 28
17100 IF(L.NE.IHH)GO TO 28
17200 IF(LN.NE.INN)GO TO 28
17300 C NCHNS
17400 IX=403
17500 RETURN
17600 24 IF(N.NE.IHH)GO TO 28
17700 IF(L.NE.IAA)GO TO 28
17800 C CHA
17900 IX=405
18000 RETURN
18100 25 IF(N.NE.IEE)GO TO 28
18200 IF(L.NE.INN)GO TO 28
18300 C GEN
18400 IX=409
18500 RETURN
18600 26 IF(N.NE.IUU)GO TO 28
18700 IF(L.NE.IRR)GO TO 28
18800 C DUR
18900 IX=410
19000 RETURN
19100 27 IF(N.NE.INN)GO TO 28
19200 IF(L.NE.ISS)GO TO 28
19300 IF(KCNT.EQ.3)GO TO 33
19400 IF(LN.NE.ITT)GO TO 28
19500 IF(I(5).NE.IRR)GO TO 28
19600 IF(I(6).NE.IUU)GO TO 28
19700 C INSTRUMENT
19800 IX=412
19900 RETURN
20000 33 IX=13
20100 C 'INS'
20200 RETURN
20300 32 IF(N.NE.IRR)GO TO 28
20400 IF(L.NE.IEE)GO TO 28
20500 IF(LN.NE.IQQ)GO TO 28
20600 C FREQ
20700 IX=411
20800 RETURN
20900 28 IX=-IPTR
21000 C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
21100 RETURN
21200
21300 2000 IF(IX.EQ.IPP)GO TO 14
21400 C FINDS (P1, P21, ETC.)
21500 IF(IX.EQ.ISS)GO TO 22
21600 C 'SRT'
21700 IF(IX.NE.IFF)GO TO 34
21800 C A FUNC??
21900 IF(N.GE.I0.AND.N.LE.I9)GO TO 15
22000 IF(KCNT.EQ.3)GO TO 28
22100 IX=510
22200 GO TO 36
22300 34 IF(IX.NE.ICC)GO TO 35
22400 IF(KCNT.EQ.3)GO TO 24
22500 C JUMP IF NOT A NOTE
22600 IX=501
22700 C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520 (CF TO BS)
22800 GO TO 36
22900 35 IF(IX.NE.IGG)GO TO 38
23000 C NOW A 'GEN' OR A NOTE
23100 IF(KCNT.EQ.3)GO TO 25
23200 IX=513
23300 C THE NOTE 'G'
23400 36 IF(KCNT.EQ.1)RETURN
23500 IF(N.EQ.IFF)GO TO 39
23600 IF(N.NE.ISS) GO TO 28
23700 C NOW IT'S NOT A NOTE
23800 40 IX=IX+1
23900 C SHARP
24000 RETURN
24100 39 IX=IX-1
24200 C FLAT
24300 RETURN
24400 38 IF(IX.NE.IDD)GO TO 41
24500 IF(KCNT.EQ.3)GO TO 26
24600 C GO LOOK FOR 'DUR'
24700 IX=504
24800 GO TO 36
24900 41 IF(IX.EQ.III)GO TO 27
25000 C CATCHES 'INS'
25100 IF(IX.NE.IEE)GO TO 42
25200 IF(KCNT.EQ.3)GO TO 4
25300 C 'END' OR NOTE 'E'?
25400 IX=507
25500 GO TO 36
25600 42 IF(KCNT.EQ.3)GO TO 28
25700 IF(IX.NE.IAA)GO TO 43
25800 IX=516
25900 GO TO 36
26000 43 IF(IX.NE.IBB)GO TO 28
26100 IX=519
26200 GO TO 36
26300
26400 END
26500
26600 SUBROUTINE ERR(N)
26700 GO TO (1,2,3,4,5)N
26800 1 TYPE 101
26900 STOP
27000 101 FORMAT(' MISSING SEMICOLON')
27100 2 TYPE 102
27200 STOP
27300 102 FORMAT(' MISSING PARENTHESIS')
27400 3 TYPE 103
27500 STOP
27600 103 FORMAT(' MISSING COMMA')
27700 4 TYPE 104
27800 104 FORMAT(' MISSING PLAY;')
27900 5 TYPE 105
28000 105 FORMAT(' UNKNOWN WORD')
28100 STOP
28200 END
28300
28400 SUBROUTINE ARITH(Y,W,LL)
28500 DIMENSION W(1)
28600 COMMON /AR/IOP
28700 47 X=W(LL-1)
28800 GO TO (41,42,43,44),IOP
28900 41 X=X*Y
29000 GO TO 45
29100 42 X=X/Y
29200 GO TO 45
29300 43 X=X-Y
29400 GO TO 45
29500 44 X=X+Y
29600 45 W(LL-1)=X
29700 END